home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / matcom.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  20.1 KB  |  658 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module matcom)
  13.  
  14. ;; This is the Match Compiler.
  15.  
  16. (DECLARE-TOP  (GENPREFIX MC_)
  17.      (SPECIAL *EXPR *RULES *RULELIST $RULES ALIST $PROPS 
  18.           *AFTERFLAG ARGS BOUNDLIST *A* PT
  19.           REFLIST TOPREFLIST PROGRAM $NOUNDISP))
  20.  
  21. (SETQ *AFTERFLAG NIL)
  22.  
  23. (DEFMSPEC $MATCHDECLARE (FORM)
  24.   (LET ((META-PROP-P NIL))
  25.     (PROC-$MATCHDECLARE (CDR FORM))))
  26.  
  27. (DEFUN PROC-$MATCHDECLARE (X)
  28.  (IF (ODDP (LENGTH X))
  29.      (MERROR "MATCHDECLARE takes an even number of arguments."))
  30.  (DO ((X X (CDDR X))) ((NULL X))
  31.      (COND ((SYMBOLP (CAR X))
  32.         (COND ((AND (NOT (SYMBOLP (CADR X)))
  33.                 (OR (NUMBERP (CADR X))
  34.                 (MEMQ (CAAADR X) '(MAND MOR MNOT MCOND MPROG))))
  35.            (IMPROPER-ARG-ERR (CADR X) '$MATCHDECLARE)))
  36.         (META-ADD2LNC (CAR X) '$PROPS)
  37.         (META-MPUTPROP (CAR X) (NCONS (CADR X)) 'MATCHDECLARE))
  38.        ((NOT ($LISTP (CAR X)))
  39.         (IMPROPER-ARG-ERR (CAR X) '$MATCHDECLARE))
  40.        (T (DO ((L (CDAR X) (CDR L))) ((NULL L))
  41.           (PROC-$MATCHDECLARE (LIST (CAR L) (CADR X)))))))
  42. '$DONE)
  43.  
  44. (DEFUN COMPILEATOM (E P) 
  45.   (PROG (D) 
  46.     (SETQ D (GETDEC P E))
  47.     (RETURN (COND ((NULL D)
  48.                (EMIT (LIST 'COND
  49.                    (LIST (LIST 'NOT
  50.                            (LIST 'EQUAL
  51.                              E
  52.                              (LIST 'QUOTE P)))
  53.                      '(MATCHERR)))))
  54.               ((MEMQ P BOUNDLIST)
  55.                (EMIT (LIST 'COND
  56.                    (LIST (LIST 'NOT (LIST 'EQUAL E P))
  57.                      '((MATCHERR))))))
  58.               (T (SETQ BOUNDLIST (CONS P BOUNDLIST)) (EMIT D))))))
  59.  
  60. (DEFUN EMIT (X) (SETQ PROGRAM (NCONC PROGRAM (LIST X))))
  61.  
  62. (DEFUN MEMQARGS (X)
  63.   (COND ((OR (NUMBERP X) (MEMQ X BOUNDLIST)) X)
  64.     ((AND (SYMBOLP X) (GET X 'OPERATORS)) `(QUOTE ,X))
  65.     ;; ((NULL BOUNDLIST) (LIST 'SIMPLIFYA (LIST 'QUOTE X) NIL))
  66.     (T `(MEVAL (QUOTE ,X)))))
  67.  
  68. (DEFUN MAKEPREDS (L GG) 
  69.        (COND ((NULL L) NIL)
  70.          (T (CONS (COND ((ATOM (CAR L))
  71.                  (LIST 'LAMBDA (LIST (SETQ GG (GENSYM)))
  72.                    `(declare (special ,gg))
  73.                    (GETDEC (CAR L) GG)))
  74.                 (T (DEFMATCH1 (CAR L) (GENSYM))))
  75.               (MAKEPREDS (CDR L) NIL)))))
  76.  
  77. (DEFUN DEFMATCH1 (PT E) 
  78.        (PROG (TOPREFLIST PROGRAM) 
  79.          (SETQ TOPREFLIST (LIST E))
  80.          (COND ((ATOM (ERRSET (COMPILEMATCH E PT)))
  81.             (merror "Match processing aborted~%"))
  82.            (T (mtell
  83. "~M Will be matched uniquely since sub-parts would otherwise be ambigious.~%" 
  84.   
  85. PT)
  86.               (RETURN (LIST 'LAMBDA
  87.                     (LIST E)
  88.                     `(declare (special ,e))
  89.                   (LIST 'CATCH ''MATCH
  90.                     (NCONC (LIST 'PROG)
  91.                            (LIST (CDR (REVERSE TOPREFLIST)))
  92.                            PROGRAM
  93.                            (LIST (LIST 'RETURN T))))))))))
  94.  
  95. (DEFUN COMPILEPLUS (E P) 
  96.        (PROG (REFLIST F G H FLAG LEFTOVER) 
  97.     A    (SETQ P (CDR P))
  98.     A1   (COND ((NULL P)
  99.             (COND ((NULL LEFTOVER)
  100.                (RETURN (EMIT (LIST 'COND
  101.                            (LIST (LIST 'NOT (LIST 'EQUAL E 0.))
  102.                              '(MATCHERR))))))
  103.               ((NULL (CDR LEFTOVER)) (RETURN (COMPILEMATCH E (CAR LEFTOVER))))
  104.               ((SETQ F (INTERSECT LEFTOVER BOUNDLIST))
  105.                (EMIT (LIST 'SETQ
  106.                        E
  107.                        (LIST 'MEVAL
  108.                          (LIST 'QUOTE
  109.                            (LIST '(MPLUS)
  110.                              E
  111.                              (LIST '(MMINUS) (CAR F)))))))
  112.                (zl-DELETE (CAR F) LEFTOVER)
  113.                (GO A1))
  114.               (T
  115.                (MTELL "~M partitions SUM"
  116.                   (CONS '(MPLUS) LEFTOVER)
  117.                   )
  118.                (SETQ BOUNDLIST (APPEND BOUNDLIST (ATOMSON LEFTOVER)))
  119.                  (RETURN (EMIT (LIST 'COND
  120.                          (LIST (LIST 'PART+
  121.                                  E
  122.                                  (LIST 'QUOTE LEFTOVER)
  123.                                  (LIST 'QUOTE
  124.                                    (MAKEPREDS LEFTOVER NIL))))
  125.                          '(T (MATCHERR))))))))
  126.            ((FIXEDMATCHP (CAR P))
  127.             (EMIT (LIST 'SETQ
  128.                 E
  129.                 (LIST 'MEVAL
  130.                       (LIST 'QUOTE
  131.                         (LIST '(MPLUS)
  132.                           E
  133.                           (LIST '(MMINUS) (CAR P))))))))
  134.            ((ATOM (CAR P))
  135.             (COND ((CDR P) (SETQ LEFTOVER (CONS (CAR P) LEFTOVER)) (SETQ P (CDR P)) (GO A1))
  136.               (LEFTOVER (SETQ LEFTOVER (CONS (CAR P) LEFTOVER)) (SETQ P NIL) (GO A1)))
  137.             (SETQ BOUNDLIST (CONS (CAR P) BOUNDLIST))
  138.             (EMIT (GETDEC (CAR P) E))
  139.             (COND ((NULL (CDR P)) (RETURN NIL)) (T (GO A))))
  140.            ((EQ (CAAAR P) 'MTIMES)
  141.             (COND ((AND (NOT (OR (NUMBERP (CADAR P))
  142.                      (AND (NOT (ATOM (CADAR P)))
  143.                           (EQ (CAAR (CADAR P)) 'RAT))))
  144.                 (FIXEDMATCHP (CADAR P)))
  145.                (SETQ FLAG NIL)
  146.                (EMIT `(SETQ ,(GENREF)
  147.                     (RATDISREP
  148.                      (RATCOEF ,E ,(MEMQARGS (CADAR P))))))
  149.                (COMPILETIMES (CAR REFLIST) (CONS '(MTIMES) (CDDAR P)))
  150.                (EMIT `(SETQ ,E (MEVAL
  151.                         (QUOTE
  152.                          (($RATSIMP)
  153.                           ((MPLUS) ,E
  154.                                ((MTIMES) -1 ,(CAR REFLIST)
  155.                                     ,(CADAR P)))))))))
  156.               ((NULL FLAG)
  157.                (SETQ FLAG T) (RPLACD (CAR P) (REVERSE (CDAR P))) (GO A1))
  158.               (T (SETQ LEFTOVER (CONS (CAR P) LEFTOVER)) (GO A))))
  159.            ((EQ (CAAAR P) 'MEXPT)
  160.             (COND ((FIXEDMATCHP (CADAR P))
  161.                (SETQ F 'FINDEXPON)
  162.                (SETQ G (CADAR P))
  163.                (SETQ H (CADDAR P)))
  164.               ((FIXEDMATCHP (CADDAR P))
  165.                (SETQ F 'FINDBASE)
  166.                (SETQ G (CADDAR P))
  167.                (SETQ H (CADAR P)))
  168.               (T (GO FUNCTIONMATCH)))
  169.             (EMIT (LIST 'SETQ
  170.                 (GENREF)
  171.                 (LIST F E (SETQ G (MEMQARGS G)) ''MPLUS)))
  172.             (EMIT (LIST 'SETQ
  173.                 E
  174.                 (LIST 'MEVAL
  175.                       (LIST 'QUOTE
  176.                         (LIST '(MPLUS)
  177.                           E
  178.                           (LIST '(MMINUS)
  179.                             (COND ((EQ F 'FINDEXPON)
  180.                                    (LIST '(MEXPT)
  181.                                      G
  182.                                      (CAR REFLIST)))
  183.                                   (T (LIST '(MEXPT)
  184.                                        (CAR REFLIST)
  185.                                        G)))))))))
  186.             (COMPILEMATCH (CAR REFLIST) H))
  187.            ((NOT (FIXEDMATCHP (CAAAR P)))
  188.             (COND ((CDR P)
  189.                (SETQ LEFTOVER (CONS (CAR P) LEFTOVER))
  190.                (SETQ P (CDR P))
  191.                (GO A1)))
  192.             (SETQ BOUNDLIST (CONS (CAAAR P) BOUNDLIST))
  193.             (EMIT (LIST 'MSETQ
  194.                 (CAAAR P)
  195.                 (LIST 'KAR (LIST 'KAR (GENREF)))))
  196.             (GO FUNCTIONMATCH))
  197.            (T (GO FUNCTIONMATCH)))
  198.          (GO A)
  199.     FUNCTIONMATCH
  200.          (EMIT (LIST 'SETQ
  201.              (GENREF)
  202.              (LIST 'FINDFUN E (MEMQARGS (CAAAR P)) ''MPLUS)))
  203.          (COND ((EQ (CAAAR P) 'MPLUS)
  204.             (MTELL "~M~%Warning: + within +~%" (CAR P))
  205.             (COMPILEPLUS (CAR REFLIST) (CAR P)))
  206.            (T (EMIT (LIST 'SETQ (GENREF) (LIST 'KDR (CADR REFLIST))))
  207.               (COMPILEEACH (CAR REFLIST) (CDAR P))))
  208.          (EMIT (LIST 'SETQ
  209.              E
  210.              (LIST 'MEVAL
  211.                    (LIST 'QUOTE
  212.                      (LIST '(MPLUS) E (LIST '(MMINUS) (CAR P)))))))
  213.          (GO A)))
  214.  
  215. (DEFUN COMPILETIMES (E P) 
  216.        (PROG (REFLIST F G H LEFTOVER) 
  217.     A    (SETQ P (CDR P))
  218.     A1   (COND ((NULL P)
  219.             (COND ((NULL LEFTOVER)
  220.                (RETURN (EMIT (LIST 'COND
  221.                            (LIST (LIST 'NOT (LIST 'EQUAL E 1.))
  222.                              '(MATCHERR))))))
  223.               ((NULL (CDR LEFTOVER)) (RETURN (COMPILEMATCH E (CAR LEFTOVER))))
  224.               ((SETQ F (INTERSECT LEFTOVER BOUNDLIST))
  225.                (EMIT (LIST 'SETQ
  226.                        E
  227.                        (LIST 'MEVAL
  228.                          (LIST 'QUOTE
  229.                            (LIST '(MQUOTIENT) E (CAR F))))))
  230.                (zl-DELETE (CAR F) LEFTOVER)
  231.                (GO A1))
  232.               (T
  233.                (MTELL "~M partitions PRODUCT"
  234.                   (CONS '(MTIMES) LEFTOVER)
  235.                   )
  236.                (SETQ BOUNDLIST (APPEND BOUNDLIST (ATOMSON LEFTOVER)))
  237.                  (RETURN (EMIT (LIST 'COND
  238.                          (LIST (LIST 'PART*
  239.                                  E
  240.                                  (LIST 'QUOTE LEFTOVER)
  241.                                  (LIST 'QUOTE
  242.                                    (MAKEPREDS LEFTOVER NIL))))
  243.                          '(T (MATCHERR))))))))
  244.            ((FIXEDMATCHP (CAR P))
  245.             (EMIT (LIST 'SETQ
  246.                 E
  247.                 (LIST 'MEVAL
  248.                       (LIST 'QUOTE (LIST '(MQUOTIENT) E (CAR P)))))))
  249.            ((ATOM (CAR P))
  250.             (COND ((CDR P) (SETQ LEFTOVER (CONS (CAR P) LEFTOVER)) (SETQ P (CDR P)) (GO A1))
  251.               (LEFTOVER (SETQ LEFTOVER (CONS (CAR P) LEFTOVER)) (SETQ P NIL) (GO A1)))
  252.             (SETQ BOUNDLIST (CONS (CAR P) BOUNDLIST))
  253.             (EMIT (GETDEC (CAR P) E))
  254.             (COND ((NULL (CDR P)) (RETURN NIL)) (T (GO A))))
  255.            ((EQ (CAAAR P) 'MEXPT)
  256.             (COND ((FIXEDMATCHP (CADAR P))
  257.                (SETQ F 'FINDEXPON)
  258.                (SETQ G (CADAR P))
  259.                (SETQ H (CADDAR P)))
  260.               ((FIXEDMATCHP (CADDAR P))
  261.                (SETQ F 'FINDBASE)
  262.                (SETQ G (CADDAR P))
  263.                (SETQ H (CADAR P)))
  264.               (T (GO FUNCTIONMATCH)))
  265.             (EMIT (LIST 'SETQ
  266.                 (GENREF)
  267.                 (LIST F E (SETQ G (MEMQARGS G)) ''MTIMES)))
  268.             (COND ((EQ F 'FINDBASE)
  269.                (EMIT (LIST 'COND
  270.                        (LIST (LIST 'EQUAL (CAR REFLIST) 0)
  271.                          '(MATCHERR))))))
  272.             (EMIT (LIST 'SETQ
  273.                 E
  274.                 (LIST 'MEVAL
  275.                       (LIST 'QUOTE
  276.                         (LIST '(MQUOTIENT)
  277.                           E
  278.                           (COND ((EQ F 'FINDEXPON)
  279.                              (LIST '(MEXPT) G (CAR REFLIST)))
  280.                             (T (LIST '(MEXPT)
  281.                                  (CAR REFLIST)
  282.                                  G))))))))
  283.             (COMPILEMATCH (CAR REFLIST) H))
  284.            ((NOT (FIXEDMATCHP (CAAAR P)))
  285.             (COND ((CDR P)
  286.                (SETQ LEFTOVER (CONS (CAR P) LEFTOVER))
  287.                (SETQ P (CDR P))
  288.                (GO A1)))
  289.             (SETQ BOUNDLIST (CONS (CAAAR P) BOUNDLIST))
  290.             (EMIT (LIST 'MSETQ
  291.                 (CAAAR P)
  292.                 (LIST 'KAR (LIST 'KAR (GENREF)))))
  293.             (GO FUNCTIONMATCH))
  294.            (T (GO FUNCTIONMATCH)))
  295.          (GO A)
  296.     FUNCTIONMATCH
  297.          (EMIT (LIST 'SETQ
  298.              (GENREF)
  299.              (LIST 'FINDFUN E (MEMQARGS (CAAAR P)) ''MTIMES)))
  300.          (COND ((EQ (CAAAR P) 'MTIMES)
  301.             (MTELL "~M~%Warning: * within *" (CAR P))
  302.             (COMPILETIMES (CAR REFLIST) (CAR P)))
  303.            (T (EMIT (LIST 'SETQ (GENREF) (LIST 'KDR (CADR REFLIST))))
  304.               (COMPILEEACH (CAR REFLIST) (CDAR P))))
  305.          (EMIT (LIST 'SETQ
  306.              E
  307.              (LIST 'MEVAL
  308.                    (LIST 'QUOTE (LIST '(MQUOTIENT) E (CAR P))))))
  309.          (GO A)))
  310.  
  311.  
  312. (DEFMSPEC $DEFMATCH (FORM)
  313.   (LET ((META-PROP-P NIL))
  314.     (PROC-$DEFMATCH (CDR FORM))))
  315.  
  316. (DEFUN PROC-$DEFMATCH (L) 
  317.   (PROG (PT PT* ARGS *A* BOUNDLIST REFLIST TOPREFLIST PROGRAM NAME tem) 
  318.     (SETQ NAME (CAR L))
  319.     (SETQ PT (COPY (SETQ PT* (SIMPLIFY (CADR L)))))
  320.     (COND ((ATOM PT)
  321.            (SETQ PT (COPY (SETQ PT* (MEVAL PT))))
  322.            (MTELL "~M~%Is the pattern~%" PT)
  323.            ))
  324.     (SETQ ARGS (CDDR L))
  325.     (COND ((NULL (ALLATOMS ARGS)) (MTELL "Non-atomic pattern variables")
  326.                       (RETURN NIL)))
  327.     (SETQ BOUNDLIST ARGS)
  328.     (SETQ *A* (GENREF))
  329.     (COND ((ATOM (ERRSET (COMPILEMATCH *A* PT)))
  330.            (merror "Match processing aborted~%"))
  331.           (T (META-FSET NAME
  332.                (LIST 'LAMBDA
  333.                  (CONS *A* ARGS)
  334.                  `(declare (special ,*a* ,@ args))
  335.                  (LIST 'CATCH ''MATCH
  336.                    (NCONC (LIST 'PROG)
  337.                       (LIST (setq tem  (CDR (REVERSE TOPREFLIST))))
  338.                         `((declare (special ,@ tem)))
  339.                       PROGRAM
  340.                       (LIST (LIST 'RETURN
  341.                               (COND (BOUNDLIST (CONS 'RETLIST
  342.                                          BOUNDLIST))
  343.                                 (T T))))))))
  344.          (META-ADD2LNC NAME '$RULES) 
  345.          (META-MPUTPROP NAME (LIST '(MLIST) PT* (CONS '(MLIST) ARGS)) '$RULE)
  346.          (RETURN NAME)))))
  347.  
  348.  
  349. (DEFUN ATOMSON (L) 
  350.        (COND ((NULL L) NIL)
  351.          ((ATOM (CAR L)) (CONS (CAR L) (ATOMSON (CDR L))))
  352.          (T (ATOMSON (CDR L)))))
  353.  
  354.  
  355. (DEFMSPEC $TELLSIMP (FORM)
  356.   (LET ((META-PROP-P NIL))
  357.     (PROC-$TELLSIMP (CDR FORM))))
  358.  
  359. (defun $clear_rules ()
  360.    (mapc 'kill1 (cdr $rules))
  361.    (sloop for v in '(mexpt mplus mtimes)
  362.      do (setf (mget v 'rulenum) nil)))
  363.  
  364. (DEFUN PROC-$TELLSIMP (L) 
  365.  (PROG (PT RHS BOUNDLIST REFLIST TOPREFLIST *A* PROGRAM NAME tem
  366.        OLDSTUFF PGNAME ONAME RULENUM) 
  367.   (SETQ PT (COPY (SIMPLIFYA (CAR L) NIL)))
  368.   (SETQ NAME PT) 
  369.   (SETQ RHS (COPY (SIMPLIFYA (CADR L) NIL)))
  370.   (COND ((ALIKE1 PT RHS) (MERROR "Circular rule attempted - TELLSIMP"))
  371.     ((OR (ATOM PT) (MGET (SETQ NAME (CAAR PT)) 'MATCHDECLARE))
  372.      (MERROR "~%~A unsuitable~%" (FULLSTRIP1 (GETOP NAME))))
  373.     ((MEMQ NAME '(MPLUS MTIMES))
  374.      (MTELL "Warning: Putting rules on '+' or '*' is inefficient, and may not work.~%")))
  375.   (SETQ *A* (GENREF))
  376.   (COND ((ATOM (ERRSET (COMPILEEACH *A* (CDR PT))))
  377.      (MERROR "Match processing aborted~%")))
  378.   (SETQ OLDSTUFF (GET NAME 'OPERATORS))
  379.   (SETQ RULENUM (MGET NAME 'RULENUM))
  380.   (COND ((NULL RULENUM) (SETQ RULENUM 1.)))
  381.   (SETQ ONAME (GETOP NAME))
  382.   (SETQ PGNAME (IMPLODE (APPEND (%TO$ (EXPLODEC ONAME))
  383.                 '(R U L E)
  384.                 (MEXPLODEN RULENUM))))
  385.   (META-MPUTPROP PGNAME NAME 'RULEOF)
  386.   (META-ADD2LNC PGNAME '$RULES)
  387.   (META-MPUTPROP NAME (f1+ RULENUM) 'RULENUM)
  388.   (META-FSET PGNAME
  389.     (LIST 'LAMBDA '(X A2 A3)
  390.           `(declare (special x a2 a3))
  391.           (LIST 'PROG
  392.             (LIST 'ANS *A*)
  393.             `(declare (special ans ,*a*))
  394.             (LIST 'SETQ
  395.               'X
  396.               (LIST 'CONS
  397.                 '(CAR X)
  398.                 (LIST 'SETQ
  399.                       *A*
  400.                       '(COND (A3 (CDR X)) 
  401.                          (T (MAPCAR #'(LAMBDA (H) (SIMPLIFYA H A3))
  402.                             (CDR X)))))))
  403.             (LIST
  404.              'SETQ
  405.              'ANS
  406.              (LIST 'CATCH ''MATCH
  407.                (NCONC (LIST 'PROG)
  408.                   (LIST (setq tem (NCONC BOUNDLIST
  409.                            (CDR (REVERSE TOPREFLIST)))))
  410.                   #+cl
  411.                   `((declare (special ,@ tem)))
  412.                   PROGRAM
  413.                   (LIST (LIST 'RETURN
  414.                           (MEMQARGS RHS))))))
  415.             (COND ((NOT (MEMQ NAME '(MTIMES MPLUS)))
  416.                (LIST 'RETURN
  417.                  (LIST 'COND
  418.                        '(ANS) '((AND (NOT DOSIMP) (MEMQ 'SIMP (CDAR X)))X)
  419.                        (LIST T
  420.                          (COND (OLDSTUFF (CONS OLDSTUFF
  421.                                    '(X A2 T)))
  422.                            (T '(EQTEST X X)))))))
  423.               ((EQ NAME 'MTIMES)
  424.                (LIST 'RETURN
  425.                  (LIST 'COND
  426.                        '((AND (EQUAL 1. A2) ANS))
  427.                        '(ANS (MEVAL '((MEXPT) ANS A2)))
  428.                        (LIST T
  429.                          (COND (OLDSTUFF (CONS OLDSTUFF
  430.                                    '(X A2 A3)))
  431.                            (T '(EQTEST X X)))))))
  432.               ((EQ NAME 'MPLUS)
  433.                (LIST 'RETURN
  434.                  (LIST 'COND
  435.                        '((AND (EQUAL 1. A2) ANS))
  436.                        '(ANS (MEVAL '((MTIMES) ANS A2)))
  437.                        (LIST T
  438.                          (COND (OLDSTUFF (CONS OLDSTUFF
  439.                                    '(X A2 A3)))
  440.                            (T '(EQTEST X X)))))))))))
  441.   (META-MPUTPROP PGNAME (LIST '(MEQUAL) PT RHS) '$RULE)
  442.   (COND ((NULL (MGET NAME 'OLDRULES))
  443.      (META-MPUTPROP NAME
  444.            (LIST (GET NAME 'OPERATORS))
  445.            'OLDRULES)))
  446.   (META-PUTPROP NAME PGNAME 'OPERATORS)
  447.   (RETURN (CONS '(MLIST)
  448.         (META-MPUTPROP NAME
  449.               (CONS PGNAME (MGET NAME 'OLDRULES))
  450.               'OLDRULES)))))
  451.  
  452. (DEFUN %TO$ (L) (COND ((EQ (CAR L) '%) (RPLACA L '$)) (L)))
  453.  
  454.  
  455. (DEFMSPEC $TELLSIMPAFTER (FORM)
  456.   (LET ((META-PROP-P NIL))
  457.     (PROC-$TELLSIMPAFTER (CDR FORM))))
  458.  
  459. (DEFUN PROC-$TELLSIMPAFTER (L) 
  460.   (PROG (PT RHS BOUNDLIST REFLIST TOPREFLIST *A* PROGRAM NAME OLDSTUFF PLUSTIMES PGNAME ONAME tem
  461.      RULENUM) 
  462.     (SETQ PT (COPY (SIMPLIFYA (CAR L) NIL)))
  463.     (SETQ NAME PT)
  464.     (SETQ RHS (COPY (SIMPLIFYA (CADR L) NIL)))
  465.     (COND ((ALIKE1 PT RHS) (MERROR "Circular rule attempted - TELLSIMPAFTER"))
  466.           ((OR (ATOM PT) (MGET (SETQ NAME (CAAR PT)) 'MATCHDECLARE))
  467.            (MERROR "~%~A unsuitable~%" (FULLSTRIP1 (GETOP NAME)))))
  468.     (SETQ *A* (GENREF))
  469.     (SETQ PLUSTIMES (MEMQ NAME '(MPLUS MTIMES)))
  470.     (IF (ATOM (IF PLUSTIMES (ERRSET (COMPILEMATCH *A* PT))
  471.                 (ERRSET (COMPILEEACH *A* (CDR PT)))))
  472.         (MERROR "Match processing aborted~%"))
  473.     (SETQ OLDSTUFF (GET NAME 'OPERATORS))
  474.     (SETQ RULENUM (MGET NAME 'RULENUM))
  475.     (IF (NULL RULENUM) (SETQ RULENUM 1))
  476.     (SETQ ONAME (GETOP NAME))
  477.     (SETQ PGNAME (IMPLODE (APPEND (%TO$ (EXPLODEC ONAME))
  478.                       '(R U L E) (MEXPLODEN RULENUM))))
  479.     (META-MPUTPROP PGNAME NAME 'RULEOF)
  480.     (META-ADD2LNC PGNAME '$RULES)
  481.     (META-MPUTPROP NAME (f1+ RULENUM) 'RULENUM)
  482.     (META-FSET
  483.      PGNAME
  484.      (LIST
  485.       'LAMBDA
  486.       '(X ANS A3)
  487.       (IF OLDSTUFF (LIST 'SETQ 'X (LIST OLDSTUFF 'X 'ANS 'A3)))
  488.       (LIST
  489.        'COND
  490.        '(*AFTERFLAG X)
  491.        (LIST 'T
  492.          (NCONC (LIST 'PROG)
  493.             (LIST (CONS *A* '(*AFTERFLAG)))
  494.             `((declare (special ,*a* *afterflag)))
  495.             (LIST '(SETQ *AFTERFLAG T))
  496.             (COND (OLDSTUFF (SUBST (LIST 'QUOTE NAME)
  497.                            'NAME
  498.                            '((COND ((OR (ATOM X) (NOT (EQ (CAAR X) NAME)))
  499.                             (RETURN X)))))))
  500.             (LIST (LIST 'SETQ
  501.                     *A*
  502.                     (COND (PLUSTIMES 'X) (T '(CDR X)))))
  503.             (LIST (LIST 'SETQ
  504.                     'ANS
  505.                   (LIST 'CATCH ''MATCH
  506.                     (NCONC (LIST 'PROG)
  507.                            (LIST (setq tem(NCONC BOUNDLIST
  508.                                 (CDR (REVERSE TOPREFLIST)))))
  509.                            #+cl
  510.                            `((declare (special ,@ tem)))
  511.                            PROGRAM
  512.                            (LIST (LIST 'RETURN
  513.                                (MEMQARGS RHS)))))))
  514.             (LIST '(RETURN (OR ANS (EQTEST X X)))))))))
  515.     (META-MPUTPROP PGNAME (LIST '(MEQUAL) PT RHS) '$RULE)
  516.     (COND ((NULL (MGET NAME 'OLDRULES))
  517.            (META-MPUTPROP NAME (LIST (GET NAME 'OPERATORS)) 'OLDRULES)))
  518.     (META-PUTPROP NAME PGNAME 'OPERATORS)
  519.         (RETURN (CONS '(MLIST)
  520.               (META-MPUTPROP NAME
  521.                 (CONS PGNAME (MGET NAME 'OLDRULES))
  522.                 'OLDRULES)))))
  523.  
  524. (DEFMSPEC $DEFRULE (FORM)
  525.   (LET ((META-PROP-P NIL))
  526.     (PROC-$DEFRULE (CDR FORM))))
  527.  
  528. ;(defvar *match-specials* nil);;Hell lets declare them all special, its safer--wfs
  529. (DEFUN PROC-$DEFRULE (L) 
  530.  (PROG (PT RHS BOUNDLIST REFLIST TOPREFLIST NAME *A* PROGRAM LHS* RHS*   tem) 
  531.        (IF (NOT (= (LENGTH L) 3)) (WNA-ERR '$DEFRULE))
  532.        (SETQ NAME (CAR L))
  533.        (IF (OR (NOT (SYMBOLP NAME)) (MOPP NAME) (MEMQ NAME '($ALL $%)))
  534.        (MERROR "Improper rule name:~%~M" NAME))
  535.        (SETQ PT (COPY (SETQ LHS* (SIMPLIFY (CADR L)))))
  536.        (SETQ RHS (COPY (SETQ RHS* (SIMPLIFY (CADDR L)))))
  537.        (SETQ *A* (GENREF))
  538.        (COND ((ATOM (ERRSET (COMPILEMATCH *A* PT)))
  539.           (MERROR "Match processing aborted~%"))
  540.          (T (META-FSET NAME
  541.               (LIST 'LAMBDA
  542.                 (LIST *A*)
  543.                 `(declare (special ,*a*))
  544.                 (LIST 'CATCH ''MATCH
  545.                   (NCONC (LIST 'PROG)
  546.                      (LIST (setq tem (NCONC BOUNDLIST
  547.                               (CDR (REVERSE TOPREFLIST)))))
  548.                      #+cl
  549.                      `((declare (special ,@ tem)))
  550.                      PROGRAM
  551.                      (LIST (LIST 'RETURN
  552.                              (MEMQARGS RHS)))))))
  553.         (META-ADD2LNC NAME '$RULES)
  554.         (META-MPUTPROP NAME (SETQ L (LIST '(MEQUAL) LHS* RHS*)) '$RULE)
  555.         (META-MPUTPROP NAME '$DEFRULE '$RULETYPE)
  556.         (RETURN (LIST '(MSETQ) NAME (CONS '(MARROW) (CDR L))))))))
  557.  
  558. (DEFUN GETDEC (P E) 
  559.   (LET (X Z) 
  560.        (COND ((SETQ X (MGET P 'MATCHDECLARE))
  561.           (COND ((NOT (ATOM (CAR X))) (SETQ X (CAR X))))
  562.           (SETQ Z (NCONC (MAPCAR 'MEMQARGS (CDR X)) (NCONS E)))
  563.           (SETQ X (CAR X))
  564.           (COND ((NOT (ATOM X)) (SETQ X (CAR X))))
  565.           (SETQ Z
  566.             (COND ((OR (MEMQ X '($TRUE T $ALL))
  567.                    (AND (FBOUNDP X) (NOT (GET X 'TRANSLATED))))
  568.                (CONS X Z))
  569.               (T ;(push (second z) *match-specials*)
  570.                  (LIST 'IS (LIST 'QUOTE (CONS (NCONS X) Z))))))
  571.           (COND ((MEMQ (CAR Z) '($TRUE T $ALL)) (LIST 'MSETQ P E))
  572.             (T (LIST 'COND
  573.                  (LIST Z (LIST 'MSETQ P E))
  574.                  '((MATCHERR)))))))))
  575.  
  576. (DEFUN COMPILEMATCH (E P) 
  577.        (PROG (REFLIST) 
  578.          (COND ((FIXEDMATCHP P)
  579.             (EMIT (LIST 'COND
  580.                 (LIST (LIST 'NOT
  581.                         (LIST 'ALIKE1
  582.                           E
  583.                           (LIST 'MEVAL (LIST 'QUOTE
  584.                             P))))
  585.                       '(MATCHERR)))))
  586.            ((ATOM P) (COMPILEATOM E P))
  587.            ((EQ (CAAR P) 'MPLUS) (COMPILEPLUS E P))
  588.            ((EQ (CAAR P) 'MTIMES) (COMPILETIMES E P))
  589.            ((AND (EQ (CAAR P) 'MEXPT)
  590.              (FIXEDMATCHP (CADR P)))
  591.             (EMIT (LIST 'SETQ
  592.                 (GENREF)
  593.                 (LIST 'FINDEXPON
  594.                       E
  595.                       (MEMQARGS (CADR P))
  596.                       ''MEXPT)))
  597.             (COMPILEMATCH (CAR REFLIST) (CADDR P)))
  598.            ((AND (EQ (CAAR P) 'MEXPT)
  599.              (FIXEDMATCHP (CADR P)))
  600.             (EMIT (LIST 'SETQ
  601.                 (GENREF)
  602.                 (LIST 'FINDBASE
  603.                       E
  604.                       (MEMQARGS (CADDR P))
  605.                       ''MEXPT)))
  606.             (COMPILEMATCH (CAR REFLIST) (CADR P)))
  607.            ((EQ (CAAR P) 'MEXPT)
  608.             (EMIT (LIST 'SETQ
  609.                 (GENREF)
  610.                 (LIST 'FINDBE E)))
  611.             (EMIT (LIST 'SETQ
  612.                 (GENREF)
  613.                 (LIST 'KAR (CADR REFLIST))))
  614.             (COMPILEMATCH (CAR REFLIST) (CADR P))
  615.             (EMIT (LIST 'SETQ
  616.                 (CADR REFLIST)
  617.                 (LIST 'KDR (CADR REFLIST))))
  618.             (COMPILEMATCH (CADR REFLIST) (CADDR P)))
  619.            (T (COMPILEATOM (LIST 'KAR
  620.                      (LIST 'KAR E))
  621.                    (CAAR P))
  622.               (EMIT (LIST 'SETQ
  623.                   (GENREF)
  624.                   (LIST 'KDR E)))
  625.               (COMPILEEACH (CAR REFLIST) (CDR P))))
  626.          (RETURN PROGRAM)))
  627.  
  628. (DEFUN GENREF NIL 
  629.     (PROG (A) 
  630.        (SETQ A (tr-GENSYM))
  631.        (SETQ TOPREFLIST (CONS A TOPREFLIST))
  632.        (RETURN (CAR (SETQ REFLIST (CONS A REFLIST))))))
  633. (DEFUN COMPILEEACH (ELIST PLIST) 
  634.      (PROG (REFLIST COUNT) 
  635.            (SETQ COUNT 0)
  636.            (SETQ REFLIST (CONS ELIST REFLIST))
  637.       A    (SETQ COUNT (f1+ COUNT))
  638.            (COND ((NULL PLIST)
  639.               (RETURN (EMIT (LIST 'COND
  640.                       (LIST (LIST 'NTHKDR ELIST (f1- COUNT))
  641.                         '(MATCHERR)))))))
  642.            (EMIT (LIST 'SETQ (GENREF) (LIST 'KAR (CADR REFLIST))))
  643.            (COMPILEMATCH (CAR REFLIST) (CAR PLIST))
  644.            (SETQ PLIST (CDR PLIST))
  645.            (SETQ REFLIST (CONS (LIST 'KDR (CADR REFLIST)) REFLIST))
  646.            (GO A)))
  647.  
  648. (DEFUN FIXEDMATCHP (X)
  649.   (COND ((NUMBERP X) T)
  650.     ((ATOM X)
  651.      (IF (OR (MEMQ X BOUNDLIST) (NULL (MGET X 'MATCHDECLARE))) T))
  652.     (T (AND (OR (MEMQ (CAAR X) BOUNDLIST)
  653.             (NULL (MGET (CAAR X) 'MATCHDECLARE)))
  654.         (FMP1 (CDR X))))))
  655.  
  656. (DEFUN FMP1 (X) (IF (NULL X) T (AND (FIXEDMATCHP (CAR X)) (FMP1 (CDR X)))))
  657.  
  658.